home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / askp.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  4.3 KB  |  117 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;
  9. ;;;    ** (c) Copyright 1981 Massachusetts Institute of Technology **
  10. ;;;
  11. ;;; Toplevel Functions: ($ASKINTEGER EXP <OPTIONAL-ARG>)
  12. ;;;
  13. ;;;                      EXP -> any Macsyma expression.
  14. ;;;                      <OPTIONAL-ARG> -> $EVEN, $ODD, $INTEGER.
  15. ;;;                                        If not given, defaults to $INTEGER.
  16. ;;;                      
  17. ;;;                      returns -> $YES, $NO, $UNKNOWN.
  18. ;;;
  19. ;;; If LIMITP is non-NIL the facts collected will be consed onto the list
  20. ;;; INTEGER-INFO.
  21. ;;;
  22. ;;; Implementors Functions: (ASK-INTEGER <EXP> <WHAT-KIND>)
  23. ;;;                         same as $ASKINTEGER with less error checking and
  24. ;;;                         requires two arguments.
  25. ;;;
  26. ;;; Support Functions: ASK-EVOD -> is a symbol an even or odd number?
  27. ;;;                    ASK-INTEGERP -> is a symbol an integer?
  28. ;;;                    ASK-PROP -> ask the user a question about a symbol.
  29. ;;;
  30.  
  31. (in-package "MAXIMA")
  32. (macsyma-module askp)
  33.  
  34. (declare-top(special limitp integer-info)
  35.      (fixnum n)
  36.      (*expr evod free $numberp MAXIMA-INTEGERP retrieve $featurep
  37.         sratsimp ssimplifya ratnump))
  38.    
  39. (defmfun $askinteger n
  40.   (if (or (> n 2) (< n 1)) (wna-err '$askinteger))
  41.   (if (= n 1) (ask-integer (arg 1) '$integer)
  42.           (if (memq (arg 2) '($even $odd $integer))
  43.           (ask-integer (arg 1) (arg 2))
  44.           (improper-arg-err (arg 2) '$askinteger))))
  45.  
  46. (defmfun ask-integer (x even-odd)
  47.   (setq x (sratsimp (sublis '((z** . 0) (*z* . 0)) x)))
  48.   (cond ((or (not (free x '$%pi)) (not (free x '$%i)) (ratnump x)) '$no)
  49.     ((eq even-odd '$integer) (ask-integerp x))
  50.     (t (ask-evod x even-odd))))
  51.  
  52. (defun ask-evod (x even-odd)
  53.   (if (and (mtimesp x) (equal (cadr x) -1)) (setq x (muln (cddr x) t)))
  54.   (let ((evod-ans (evod x)) (is-integer (MAXIMA-INTEGERP x)))
  55.     (cond ((equal evod-ans even-odd) '$yes)
  56.       ((and ($numberp x) (not is-integer)) '$no)
  57.       ((and is-integer evod-ans) '$no)
  58.       ((eq (setq evod-ans
  59.              (ask-prop x
  60.                    (if (eq even-odd '$even) '|even| '|odd|)
  61.                    '|number|))
  62.            '$yes)
  63.        (ask-declare x even-odd) '$yes)
  64.       ((eq evod-ans '$no) 
  65.        (if is-integer 
  66.            (if (eq even-odd '$even) (ask-declare x '$odd)
  67.                         (ask-declare x '$even)))
  68.        '$no)
  69.       (t '$unknown))))
  70.  
  71. (defun ask-integerp (x)
  72.   (let (integer-ans)
  73.     (if (and (mplusp x) (integerp (cadr x))) (setq x (addn (cddr x) t)))
  74.     (if (and (mtimesp x) (equal (cadr x) -1)) (setq x (muln (cddr x) t)))
  75.     (cond ((or (MAXIMA-INTEGERP x) (memalike x integerl)) '$yes)
  76.       ((or ($numberp x) (nonintegerp x) (memalike x nonintegerl)) '$no)
  77.       ((eq (setq integer-ans (ask-prop x '|integer| nil)) '$yes)
  78.        (ask-declare x '$integer) '$yes)
  79.       ((eq integer-ans '$no)
  80.        (ask-declare x '$noninteger) '$no)
  81.       (t '$unknown))))
  82.  
  83. (defun ask-declare (x property)
  84.   (cond ((atom x)
  85.      (meval `(($declare) ,x ,property))
  86.      (if limitp 
  87.          (setq integer-info (cons `(($kind) ,x ,property) integer-info))))
  88.     ((and limitp (eq property '$integer))
  89.      (setq integerl (cons x integerl)))
  90.     ((and limitp (eq property '$noninteger))
  91.      (setq nonintegerl (cons x nonintegerl)))))
  92.  
  93. (defun ask-prop (object property fun-or-number)
  94.        (if fun-or-number (setq fun-or-number (list '| | fun-or-number)))
  95. ;;; Asks the user a question about the property of an object.
  96. ;;; Returns only $yes, $no or $unknown.
  97.        (do ((end-flag) (answer))
  98.        (end-flag (cond ((memq answer '($yes $y |$y|)) '$yes)
  99.                ((memq answer '($no $n |$n|)) '$no)
  100.                ((memq answer '($unknown $uk)) '$unknown)))
  101.        (setq answer (retrieve
  102.              `((mtext) |Is  | ,object 
  103.                    ,(if (zl-MEMBER (getcharn property 1)
  104.                             '(#\a #\e #\i #\o #\u))
  105.                     '|  an |
  106.                     '|  a |)
  107.                    ,property ,@fun-or-number |?|)
  108.              nil))
  109.        (cond 
  110.         ((memq answer '($yes $y |$y| |$n| $no $n $unknown $uk))
  111.          (setq end-flag t))
  112.         (t (mtell
  113.         "~%Acceptable answers are Yes, Y, No, N, Unknown, Uk~%")))))
  114.  
  115. #-NIL
  116. (declare-top(notype n))
  117.